home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tpb4_src.zip / UTILMNU2.PAS < prev   
Pascal/Delphi Source File  |  1988-09-13  |  12KB  |  458 lines
  1. { TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen  
  2.   Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault  
  3.   
  4.   Last modified  ::  5-12-88 1:22 am 
  5. }
  6.  
  7. {$R-}                             {Range checking off}
  8. {$B-}                             {Boolean complete evaluation off}
  9. {$S-}                             {Stack checking off}
  10. {$I+}                             {I/O checking on}
  11. {$N-}                             {No numeric coprocessor}
  12.  
  13. Unit Utilmnu2;
  14.  
  15. Interface
  16.  
  17. Uses
  18.   TPCrt, Dos, Globals, Core1,
  19.   Core2, TPSTRING, TPDOS, Dirs;
  20.   
  21.   
  22. procedure show_user_stats;
  23.  
  24. procedure get_protocol;
  25.  
  26. procedure get_old_password(pr : StrPr; var valid : Boolean);
  27.  
  28. procedure get_new_password;
  29.  
  30. procedure get_case;
  31.  
  32. procedure get_nulls;
  33.  
  34. procedure get_phone;
  35.  
  36. procedure graphics_on;
  37.  
  38. procedure graphics_off;
  39.  
  40.  
  41.   {==========================================================================}
  42.   
  43.   
  44. Implementation
  45.  
  46.  
  47.   procedure show_user_stats;
  48.   
  49.   
  50.   var
  51.     Str             : StrTAD;
  52.     proto           : StrPr;
  53.     time_on,
  54.     time_left,
  55.     time_today,
  56.     time_total      : Integer;
  57.     dollars         : Real;
  58.     
  59.   begin
  60.     Seek(logr_file, 0);
  61.     Read(logr_file, logr_rec);
  62.     Str := FormTAD(login_t);
  63.     WriteLn(Com);
  64.     WriteLn(Com, 'Login             : ', Str);
  65.     if user_rec.access >= val_acc then
  66.       Write(Com, 'Validated User    : ')
  67.     else
  68.       Write(Com, 'Non-Validated User: ');
  69.     WriteLn(Com, user_rec.fn, ' ', user_rec.ln);
  70.     WriteLn(Com);
  71.     timer(time_on, time_left);
  72.     time_today := user_rec.time_today+time_on;
  73.     time_total := user_rec.time_total+time_on;
  74.     WriteLn(Com, 'Caller number     : ', logr_rec.user);
  75.     WriteLn(Com, 'Access time today : ', time_today);
  76.     WriteLn(Com, 'Access time total : ', time_total);
  77.     Str := FormTAD(user_rec.laston);
  78.     WriteLn(Com, 'Last on system    : ', Str);
  79.     WriteLn(Com, 'Last high message : ', user_rec.lasthi);
  80.     Write(Com, 'Uploads to date   : ', user_rec.upload);
  81.     case CreditType of
  82.       Points :
  83.         WriteLn(Com, '   (# of Points )');
  84.       Kilobytes :
  85.         WriteLn(Com, '   (# of Kilobytes)');
  86.       Files :
  87.         WriteLn(Com);
  88.     end;
  89.     WriteLn(Com, 'Downloads to date : ', user_rec.download);
  90.     Write(Com, 'Ratio allowed     : ');
  91.     if user_rec.ratio = 0 then
  92.       WriteLn(Com, 'Unlimited')
  93.     else
  94.       WriteLn(Com, user_rec.ratio, ' to 1');
  95.     dollars := (Int(user_rec.acct_bal)/100);
  96.     WriteLn(Com, 'Account balance   : $', dollars:4:2);
  97.     case user_rec.protocol of
  98.       'X' :
  99.         proto := 'Xmodem CRC';
  100.       'Y' :
  101.         proto := 'Ymodem';
  102.       'B' :
  103.         proto := 'Ymodem Batch';
  104.       'Z' :
  105.         proto := 'Zmodem';
  106.       'C' :
  107.         proto := 'Xmodem Checksum';
  108.       'Q' :
  109.         proto := 'Ymodem G (Qmodem)';
  110.       'O' :
  111.         proto := 'Xmodem OverThruster';
  112.       'G' :
  113.         proto := 'Ymodem G';
  114.     end;
  115.     WriteLn(Com, 'Default protocol  : ', proto);
  116.     WriteLn(Com);
  117.     if cmd_tail and (time_left = (time_to_event-time_on)) then
  118.       WriteLn(Com, BEL, BEL, BEL,
  119.         'Your time limit on this call has been adjusted for an upcoming event.');
  120.     WriteLn(Com);
  121.   end;
  122.   
  123.   
  124.   
  125.   procedure get_protocol;
  126.   
  127.   var
  128.     prompt_str      : StrStd;
  129.     
  130.   begin
  131.     repeat
  132.       WriteLn(Com);
  133.       if AllowMNP then
  134.         prompt_str := 'Default protocol <X><C><Y><B><Z><G><Q><O><?>'
  135.       else
  136.         prompt_str := 'Default protocol <X><C><Y><B><Z><O><?>';
  137.       st := prompt(prompt_str, 80, 'ES?M');
  138.       if Length(st) = 1 then
  139.         ch := st[1]
  140.       else
  141.         ch := '?';
  142.       if ch in ['X', 'C', 'Y', 'B', 'Z', 'G', 'Q', 'O'] then
  143.         begin
  144.           user_rec.protocol := ch;
  145.           WriteLn(Com);
  146.           WriteLn(Com, 'You can override your default by appending the desired protocol');
  147.           WriteLn(Com, 'letter to the ''S'' or ''R'' commands, i.e. ''SZ'' for ''Send Zmodem''.');
  148.         end
  149.       else
  150.         begin
  151.           WriteLn(Com);
  152.           WriteLn(Com, 'X - Xmodem CRC');
  153.           WriteLn(Com, 'C - Xmodem Checksum');
  154.           WriteLn(Com, 'Y - Ymodem (Xmodem 1k)');
  155.           WriteLn(Com, 'B - Ymodem Batch (True Ymodem)');
  156.           WriteLn(Com, 'Z - Zmodem');
  157.           if AllowMNP then
  158.             WriteLn(Com, 'G - Ymodem G Batch');
  159.           if AllowMNP then
  160.             WriteLn(Com, 'Q - Ymodem G (Qmodem compatible)');
  161.           WriteLn(Com, 'O - Xmodem OverThruster');
  162.         end
  163.     until (not Online) or (ch in ['X', 'C', 'Y', 'B', 'Z', 'G', 'Q', 'O']);
  164.   end;
  165.   
  166.   
  167.   
  168.   procedure get_old_password(pr              : StrPr;
  169.                              var valid       : Boolean);
  170.     { Accept and validate old password.  Only 'Max_Tries' will be allowed. }
  171.     
  172.   var
  173.     tries           : Integer;
  174.     
  175.   begin
  176.     tries := 0;
  177.     repeat
  178.       valid := (user_rec.pw = prompt(pr, len_pw, 'S'));
  179.       Inc(tries)
  180.     until (not Online) or valid or (tries = max_tries);
  181.     if not valid then
  182.       WriteLn(Com, 'Only ', max_tries, ' tries allowed.')
  183.   end;
  184.   
  185.   
  186.   
  187.   procedure get_new_password;
  188.     { Accept and validate new password. }
  189.     
  190.   var
  191.     i, x            : Integer;
  192.     trial_pw        : password;
  193.     
  194.   begin
  195.     WriteLn(Com);
  196.     WriteLn(Com, 'Please select and enter a password of 4-', len_pw, ' characters');
  197.     WriteLn(Com, 'to ensure that no one else uses your name on the system.');
  198.     WriteLn(Com);
  199.     repeat
  200.       repeat
  201.         trial_pw := prompt('Password (will NOT display as you type)', len_pw, 'SL');
  202.         i := Length(trial_pw);
  203.         if (i < 4) or (i > len_pw) then
  204.           WriteLn(Com, 'Length must be 4-', len_pw, ' characters.')
  205.         else
  206.           begin
  207.             for x := 1 to Length(trial_pw) do
  208.               if (not(Ord(trial_pw[x]) in [33..90])) then
  209.                 i := 0;
  210.             if i = 0 then
  211.               WriteLn(Com, 'Only ASCII text characters allowed.');
  212.           end;
  213.       until (not Online) or ((4 <= i) and (i <= len_pw));
  214.       user_rec.pw := prompt(' Please enter it again for verification', len_pw, 'SL');
  215.       if user_rec.pw <> trial_pw then
  216.         WriteLn(Com, 'No match.  Try again.')
  217.     until (not Online) or (user_rec.pw = trial_pw);
  218.     WriteLn(Com);
  219.     WriteLn(Com, 'Please remember your password.');
  220.     WriteLn(Com, 'It will be required for all future calls.')
  221.   end;
  222.   
  223.   
  224.   
  225.   procedure get_case;
  226.     { Get case switch from user }
  227.     
  228.   begin
  229.     user_rec.shift_lock := not ask('Can your terminal display lower case', 'Y')
  230.   end;
  231.   
  232.   
  233.   
  234.   procedure get_nulls;
  235.     { Get nulls from user }
  236.     
  237.   begin
  238.     if Online then
  239.       user_rec.nulls := strint(prompt('How many [0-99] nulls do you need? [Usually 0] ', 2, 'ES'))
  240.   end;
  241.   
  242.   
  243.   
  244.   procedure get_phone;            { Get phone number from user }
  245.   
  246.   var
  247.     digits          : Byte;
  248.     Str             : string[12];
  249.     
  250.     procedure check_number;
  251.     
  252.     var
  253.       OK, error       : Boolean;
  254.       i               : Integer;
  255.       test_ph         : string;
  256.       bad_numbers     : Text;
  257.       
  258.     begin
  259.       with user_rec do
  260.         begin
  261.           OK := False;
  262.           i := 1;
  263.           test_ph := ph;
  264.           repeat
  265.             Delete(test_ph, Pos('-', test_ph), 1);
  266.           until (Pos('-', test_ph) = 0);
  267.           repeat
  268.             ch := test_ph[i];
  269.             if (ch <> test_ph[Succ(i)]) then
  270.               OK := True;
  271.             Inc(i);
  272.           until OK or (i = 10);
  273.           if (Pos('800', test_ph) = 1) then
  274.             OK := False;
  275.           Delete(test_ph, 1, 3);
  276.           if (Pos('555', test_ph) = 1) or (Pos('911', test_ph) = 1) then
  277.             OK := False;
  278.           if OK and ExistFile('BADNUMS.LST') then
  279.             begin
  280.               Assign(bad_numbers, 'BADNUMS.LST');
  281.               Reset(bad_numbers);
  282.               repeat
  283.                 {$I-}
  284.                 ReadLn(bad_numbers, test_ph) {$I+} ;
  285.                 error := (IoResult <> 0);
  286.                 if ph = test_ph then
  287.                   OK := False;
  288.               until EOF(bad_numbers) or (not OK) or error;
  289.               Close(bad_numbers)
  290.             end;
  291.           if (not OK) then
  292.             begin
  293.               Log(19, 'Phone');
  294.               Write(Com, BEL);
  295.               for i := 1 to 12 do
  296.                 Write(Com, BS, ' ', BS);
  297.               ph := '';
  298.               digits := 0
  299.             end;
  300.         end;
  301.     end;
  302.     
  303.   begin
  304.     with user_rec do
  305.       begin
  306.         ph := '';
  307.         if format then
  308.           begin
  309.             Write(Com, 'Your phone number [###-###-####] > ');
  310.             digits := 0;
  311.             repeat
  312.               ch := GetChar;
  313.               if ch in ['0'..'9'] then
  314.                 begin
  315.                   Write(Com, ch);
  316.                   ph := ph+ch;
  317.                   Inc(digits);
  318.                 end
  319.               else if (ch in [RUB, BS]) and (digits > 0) then
  320.                 begin
  321.                   Write(Com, BS, ' ', BS);
  322.                   if (digits = 4) or (digits = 8) then
  323.                     begin
  324.                       Write(Com, BS, ' ', BS);
  325.                       ph[0] := Chr(Pred(Ord(ph[0])));
  326.                       Dec(digits)
  327.                     end;
  328.                   Dec(digits);
  329.                   ph[0] := Chr(Pred(Ord(ph[0])));
  330.                 end
  331.               else if (not(ch in ['-', NUL, RUB, BS, CR])) then
  332.                 begin
  333.                   Write(Com, ch);
  334.                   Write(Com, BEL);
  335.                   Write(Com, BS, ' ', BS)
  336.                 end;
  337.               if (digits in [3, 7]) then
  338.                 begin
  339.                   Write(Com, '-');
  340.                   Inc(digits);
  341.                   ph := ph+'-'
  342.                 end;
  343.               if Length(ph) = 12 then
  344.                 check_number;
  345.             until (Length(ph) = 12) or (not online);
  346.             WriteLn(Com);
  347.           end
  348.         else
  349.           begin
  350.             Str := prompt('Your phone number', len_ph, 'EL');
  351.             if Str <> '' then
  352.               ph := Str;
  353.           end;
  354.       end;
  355.   end;
  356.   
  357.   
  358.   procedure clear_sysm_heap;
  359.   
  360.   var
  361.     thisS           : SysmPtr;
  362.   begin
  363.     while SysmBase <> nil do      { Delete out system msg linked list }
  364.       begin
  365.         thisS := SysmBase;
  366.         SysmBase := SysmBase^.next; { Go to next on chain }
  367.         Dispose(thisS)            { Reclaim space }
  368.       end;
  369.   end;
  370.   
  371.   
  372.   
  373.   procedure make_index;
  374.   
  375.   var
  376.     i               : Integer;
  377.     SysmThis,
  378.     SysmLast        : SysmPtr;
  379.     
  380.   begin
  381.     i := 0;
  382.     SysmBase := nil;
  383.     Reset(sysm_file);
  384.     Read(sysm_file, sysm_rec);
  385.     while not EoF(sysm_file) do
  386.       begin
  387.         if sysm_rec[1] = ':' then
  388.           begin
  389.             New(SysmThis);
  390.             if SysmBase = nil then
  391.               SysmBase := SysmThis
  392.             else
  393.               SysmLast^.next := SysmThis;
  394.             SysmLast := SysmThis;
  395.             SysmLast^.key := sysm_rec[2];
  396.             SysmLast^.loc := i;
  397.             SysmLast^.next := nil;
  398.           end;
  399.         Read(sysm_file, sysm_rec);
  400.         Inc(i);
  401.       end;
  402.   end;
  403.   
  404.   
  405.   procedure clear_colors;
  406.   
  407.   begin
  408.     hi := '';
  409.     low := '';
  410.     green := '';
  411.     yellow := '';
  412.     cyan := '';
  413.     white := '';
  414.   end;
  415.   
  416.   procedure graphics_on;
  417.   
  418.   var
  419.     temp            : Str72;
  420.     
  421.   begin
  422.     Close(sysm_file);
  423.     Assign(sysm_file, sysmg_name+ext);
  424.     clear_sysm_heap;
  425.     make_index;
  426.     graphics := True;
  427.     temp := question;
  428.     temp := StUpcase(temp);
  429.     if Pos('COLOR', temp) <> 0 then
  430.       begin
  431.         hi := ESC+'[1m';
  432.         low := ESC+'[0m';
  433.         green := ESC+'[32m';
  434.         yellow := ESC+'[33m';
  435.         cyan := ESC+'[36m';
  436.         white := ESC+'[37m';
  437.       end
  438.     else
  439.       clear_colors;
  440.   end;
  441.   
  442.   
  443.   
  444.   procedure graphics_off;
  445.   
  446.   begin
  447.     Close(sysm_file);
  448.     Assign(sysm_file, sysm_name+ext);
  449.     clear_sysm_heap;
  450.     make_index;
  451.     graphics := False;
  452.     clear_colors;
  453.   end;
  454.   
  455.   
  456. end.                              { of UTILMNU2.PAS }
  457. 
  458.